home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / HyperCard Related / XCMDs & XFCNs / Logic Manager / Stacks / hick.p < prev    next >
Encoding:
Text File  |  1991-03-13  |  9.2 KB  |  269 lines  |  [TEXT/TOPU]
  1. % Logic Manager Copyright 1990 by Apple Computer, Inc.
  2. % Ruben Kleiman (Advanced Technology Group)
  3.  
  4. % This is the program for the Hick stack written in
  5. % Logic Manager syntax.  It is possible to write this
  6. % in Edinburgh Prolog and convert it to LM syntax
  7. % using the Prolog program LMIMCONV.  See user
  8. % guide for instructions on how to use that program.
  9.  
  10.  trait(bud_scales(valvate),bitternut_hickory). 
  11.  trait(buds(yellow),bitternut_hickory).
  12.  
  13.  trait(bud_scales(valvate),pecan_hickory).
  14.  trait(buds(brownish),pecan_hickory).
  15.  
  16.  trait(bud_scales(imbricate),pignut_hickory).
  17.  trait(terminal_buds(short),pignut_hickory).
  18.  
  19.  trait(bud_scales(imbricate), mockernut_hickory).
  20.  trait(terminal_buds(large),mockernut_hickory).
  21.  trait(outer_scales(deciduous),mockernut_hickory).
  22.  
  23.  trait(bud_scales(imbricate),shellbark_hickory).
  24.  trait(terminal_buds(large),shellbark_hickory).
  25.  trait(outer_scales(persistent),shellbark_hickory).
  26.  trait(twigs(orange_brown),shellbark_hickory).
  27.  
  28.  trait(bud_scales(imbricate),shagbark_hickory).
  29.  trait(terminal_buds(large),shagbark_hickory).
  30.  trait(outer_scales(persistent),shagbark_hickory).
  31.  trait(twigs(reddish_brown),shagbark_hickory).
  32.  
  33. rule(id,warm_start).
  34.  
  35. rule(warm_start, 
  36.     and(analyze_chars_traits,
  37.     and(cut,identify_loop))).
  38.  
  39. rule(identify_loop, 
  40.     and(clearWindow(left),
  41.     and(clearWindow(middle),
  42.     and(clearWindow(right),
  43.     and(clearWindow(results),
  44.     and(clearWindow(debug),
  45.     and(obtain_description,
  46.     and(entertain_hypothesis(Identification),
  47.     and(validate(Identification),
  48.     and(report(Identification),
  49.     and(abolish(user_observed,1),
  50.     and(abolish(does_not_hold,1),
  51.     and(abolish(noted,1),
  52.     and(cut,
  53.     and(writeWindow(after,user,'Select action with menu...',nl),
  54.     and(menu(cons(identify,cons(exit,nil)),Choice,exit_choice), final_act(Choice)
  55.     )))))))))))))))).
  56.  
  57. rule(final_act(identify),
  58.     and(cut, identify_loop)).
  59. rule(final_act(exit), halt).
  60.  
  61. rule(analyze_chars_traits,
  62.     and(setof(ChTr, @^(Tree,trait(ChTr,Tree)), CharsTraits),
  63.     and(group_up(CharsTraits, GrChTrs),
  64.     and(setof(Char, @^(L,char_trs(Char,L)), Chars),assertz(characteristics(Chars)))))).
  65.  
  66. rule(group_up(nil, nil), cut ).
  67. rule(group_up(L, cons(char_trs(Funct, Args), RestSubGrs)),
  68.     and(=(L, cons(FirstL, RestL)),
  69.     and(functor(FirstL, Funct,1),
  70.     and(strip_group(L, Funct, Args, RemainderL),
  71.     and(assertz(char_trs(Funct, Args)), group_up(RemainderL, RestSubGrs)))))).
  72.  
  73. rule(strip_group(nil, _, nil, nil), cut).
  74. rule(strip_group(cons(Entry, RestL), Funct, cons(Arg, Args), RemainderL),
  75.     and(functor(Entry, Funct, 1),
  76.     and(cut,
  77.     and(arg(1, Entry, Arg), strip_group(RestL, Funct, Args, RemainderL))))).
  78. strip_group(L, _, nil, L).
  79.  
  80.  
  81. helpText(obtain_description_1,
  82.     'Descriptors are pairs of the form: Characteristic  Attribute. This menu
  83.     lets you first choose a Characteristic. The next menu will let you choose
  84.     an appropriate Attribute. If you have no more descriptors to input, choose
  85.     done').
  86.  
  87. helpText(obtain_description_2,
  88.     'Descriptors are pairs of the form: Characteristic  Attribute. The previous
  89.     menu let you choose a characteristic. This menu will lets you choose an
  90.     appropriate Attribute').
  91.  
  92. rule(clearWindow(Win),
  93.     and(list2atom(cons('put empty into field ',cons(Win,nil)), S), sendcardmsg(S) )).
  94.  
  95. rule(writeWindow(How,Where,What,none),
  96.     and(list2atom(cons('put "',cons(What,cons('" ',cons(How,cons(' field ',cons(Where,nil)))))),S),
  97.     sendcardmsg(S))).
  98.     
  99. rule(writeWindow(How,Where,What,nl),
  100.     and(list2atom(cons('put "',cons(What,cons('" & return ',cons(How,cons(' field ',cons(Where,nil)))))),S),
  101.     sendcardmsg(S))).
  102.  
  103. writeWindow(How,Where,nil,list).
  104. rule(writeWindow(How,Where,cons(First,Rest),list),
  105.     and(writeWindow(How,Where,First,none), writeWindow(after,Where,Rest,list))).
  106.  
  107. rule(writeWindow(How,Where,What,listnl),
  108.     and(writeWindow(How,Where,What,list),
  109.     and(list2atom(cons('put return after field ',cons(Where,nil)),S), sendcardmsg(S)))).
  110.     
  111. writeWindow(How,Where,nil,display).
  112. rule(writeWindow(How,Where,cons(First,Rest),display),
  113.     and(writeWindow(How,Where,First,nl), writeWindow(after,Where,Rest,display))).
  114.  
  115. rule(menu(Items, Chosen, Help),
  116.     and(helpText(Help, Text),
  117.     and(setglobal(helpText,Text),
  118.     and(quotelist(Items,'"',Quoted),
  119.     and(list2atom(cons('menu ',Quoted),S),
  120.     and(sendcardmsg(S), getglobal(menuChoice,Chosen))))))).
  121.  
  122. quotelist(nil,QStr,cons('"',nil)).
  123. rule(quotelist(cons(First,Rest),QStr,cons(QStr,cons(First,RestList))),
  124.     quotelist(Rest,'","',RestList)).
  125.  
  126. rule(obtain_description,
  127.     and(characteristics(Chars),
  128.     and(writeWindow(into,user,'Characteristic = ',none),
  129.     and(menu(cons(done,Chars), ChosenChar, obtain_description_1),
  130.     and(writeWindow(after,user,ChosenChar,nl),
  131.     and(
  132.         or(and(or(=(ChosenChar,done),=(ChosenChar,$noChoice)),=(Observer_1,done)),
  133.         and(not(or(=(ChosenChar,done),=(ChosenChar,$noChoice))),
  134.         and(writeWindow(after,user,'Attribute = ',none),
  135.         and(char_trs(ChosenChar,Traits),
  136.         and(menu(Traits, ChosenTrait, obtain_description_2),
  137.         and(writeWindow(after,user,ChosenTrait,nl),
  138.             or(and(=(ChosenTrait,$noChoice), =(Observer_1,done)),
  139.             and(not(=(ChosenTrait,$noChoice)),
  140.              univ(Observer_1,cons(ChosenChar, cons(ChosenTrait,nil)))
  141.             ))
  142.         )))))),
  143.     and(equivalent(Observer_1, Observer), dispatch(Observer)))))))).
  144.  
  145. rule(dispatch(done),cut).
  146. rule(dispatch(Observation),
  147.     and(asserta(user_observed(Observation)),
  148.     and(writeWindow(after,left,Observation,nl), obtain_description))).
  149.  
  150.  
  151. rule(entertain_hypothesis(Identification),
  152.     and(user_observed(Characteristic), trait(Characteristic, Identification))).
  153. rule(entertain_hypothesis(Identification),
  154.     and(user_observed(Characteristic_1),
  155.     and(equivalent(Characteristic_1, Characteristic),trait(Characteristic, Identification)))).
  156. rule(entertain_hypothesis(Identification),
  157.     and(not(user_observed(_)), trait(_, Identification))).
  158. rule(entertain_hypothesis(Identification),
  159.     and(user_observed(Characteristic), trait(Characteristic, Identification))).
  160.     
  161. helpText(exit_choice,'Identify another tree, Exit from the Identification program').
  162.  
  163. rule(entertain_hypothesis(_),
  164.     and(writeWindow(into,user,'No tree in database with those characteristics',nl),
  165.     and(abolish(user_observed,1),
  166.     and(abolish(does_not_hold,1),
  167.     and(abolish(noted,1),
  168.     and(clearWindow(left),
  169.     and(clearWindow(middle),
  170.     and(clearWindow(right),
  171.     and(writeWindow(after,user,'Select action with menu...',nl),
  172.     and(menu(cons(identify,cons(exit,nil)),Choice,exit_choice), final_act(Choice))))))))))).
  173.  
  174. rule(observed(X), user_observed(X)).
  175.  
  176. rule(not_observed(X), does_not_hold(X)).
  177.  
  178. rule(validate(Identification),
  179.     and(bagof(Attribute, trait(Attribute,Identification), Characterization),
  180.     and(verify(Characterization), cut))).
  181.  
  182. verify(nil).                                      
  183. rule(verify(cons(Attribute, Rest_of_Attributes)),
  184.     and(check(Attribute), verify(Rest_of_Attributes))).
  185.  
  186. rule(check(Attribute),
  187.     and(observed(Attribute),
  188.     and(note_inference(Attribute), cut))).   
  189. rule(check(Attribute),
  190.     and(not_observed(Attribute),
  191.     and(cut,fail))).
  192. rule(check(Attribute),
  193.     and(ask_about(Attribute),cut)).
  194.  
  195. rule(note_inference(Attribute),
  196.     and(noted(Attribute),cut)).
  197. rule(note_inference(Attribute),
  198.    and(assertz(noted(Attribute)), writeWindow(after,right,Attribute,nl))).
  199.  
  200. helpText(ask_about_attribute,'Validating a conjecture...Choose True if the attribute is present, False if not.').
  201.  
  202. rule(ask_about(Attribute),
  203.     and(writeWindow(after,user,cons('Is it true that ', cons(Attribute, cons('?',nil))),list),
  204.     and(menu(cons(true,cons(false,nil)),Answer,ask_about_attribute),
  205.     and(cut, 
  206.     and(writeWindow(after,user,Answer,nl),act_on(Answer, Attribute)))))).
  207.  
  208. rule(act_on(true, Attribute),
  209.     and(writeWindow(after,middle,Attribute,nl),
  210.     and(asserta(user_observed(Attribute)), cut))).
  211. rule(act_on(false, Attribute),
  212.     and(asserta(does_not_hold(Attribute)),
  213.     and(cut,fail))).
  214.  
  215. rule(report(Identification),
  216.     and(writeWindow(into,user, cons('The tree appears to be a ', cons(Identification,nil)),listnl),
  217.     and(bagof(Characteristic, trait(Characteristic, Identification), Traits),
  218.     writeWindow(into,results, cons('Identifying traits ',Traits),display)
  219.     ))).
  220.  
  221. rule(observed(outer_scales(X)),
  222.     and(opposite(X,Y), does_not_hold(outer_scales(Y)))).
  223.  
  224. rule(observed(terminal_buds(X)),
  225.     and(opposite(X,Y), does_not_hold(terminal_buds(Y)))).
  226.  
  227. rule(observed(bud_scales(X)),
  228.     and(opposite(X,Y), does_not_hold(bud_scales(Y)))).
  229.  
  230. opposite(short,large).
  231. opposite(large,short).
  232. opposite(deciduous,persistent).
  233. opposite(persistent,deciduous).
  234. opposite(valvate,imbricate).
  235. opposite(imbricate,valvate).
  236.  
  237. rule(observed(outer_scales(X)),
  238.     and(synonymous(X,Y), observed(outer_scales(Y)))).
  239.  
  240. rule(observed(terminal_buds(X)),
  241.     and(synonymous(X,Y), observed(terminal_buds(Y)))).
  242.  
  243. rule(observed(bud_scales(X)),
  244.     and(synonymous(X,Y), observed(bud_scales(Y)))).
  245.  
  246. synonymous(valvate,non_overlapping).
  247. synonymous(imbricate,overlapping).
  248. synonymous(short,stout).
  249.  
  250. rule(not_observed(outer_scales(X)),
  251.     and(opposite(X,Y), user_observed(outer_scales(Y)))).
  252. rule(not_observed(terminal_buds(X)),
  253.     and(opposite(X,Y), user_observed(terminal_buds(Y)))).
  254. rule(not_observed(bud_scales(X)),
  255.     and(opposite(X,Y), user_observed(bud_scales(Y)))).
  256. rule(not_observed(outer_scales(X)),
  257.     and(synonymous(X,Y), not_observed(outer_scales(Y)))).
  258. rule(not_observed(terminal_buds(X)),
  259.     and(synonymous(X,Y), not_observed(terminal_buds(Y)))).
  260. rule(not_observed(bud_scales(X)),
  261.     and(synonymous(X,Y), not_observed(bud_scales(Y)))).
  262.  
  263. rule(equivalent(U,V),
  264.     and(univ(U, cons(P,cons(X,nil))),
  265.     and(synonymous(Y,X),
  266.     and(univ(V, cons(P,cons(Y,nil))), cut)))).
  267.  
  268. equivalent(U,U).
  269.